home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
SORT_UTL
/
ASORTS
/
ASORTS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-02-28
|
8KB
|
231 lines
unit asorts;
{ General-purpose array manipulation routines }
{ Copyright 1991, by J. W. Rider }
interface
{ $define MONITOR} { <--- remove space before "$" to enable
monitoring "qsort" }
{$ifdef MONITOR}
var monitor : procedure; { for monitoring results of sort }
procedure nullmonitor; { to turn monitoring off }
{$endif}
{ "comparefunc" -- comparison function argument for "qsort", "bsearch"
"lfind" and "lsearch" }
type comparefunc = function (var a,b):longint;
{ "qsort", "bsearch", "lfind" and "lsearch" are analogous to C functions of
the same names }
{ quicksort the elements of an array }
procedure qsort(var base; length_base, sizeof_element:word;
f:comparefunc);
{ binary search a sorted array for an element}
function bsearch(var key,base; length_base, sizeof_element:word;
f:comparefunc):word;
{ linear search an array for an element }
function lfind(var key,base; length_base, sizeof_element:word;
f:comparefunc):word;
{ linear search an array for an element; append if not found }
function lsearch(var key,base; length_base, sizeof_element:word;
f:comparefunc):word;
{ the remaining routines generally have no standard implementation in other
languages }
{ binary search a sorted array for an element. Return the index of
its location, or the negative of the index where it should be inserted }
function bfind(var key,base; length_base, sizeof_element:word;
f:comparefunc):longint;
{ inserts an element into a sorted array. }
function binsert(var key,base; length_base, sizeof_element:word;
f:comparefunc):word;
{ fill an array with an element }
procedure fill(var key,destination; count, sizeof_element:word);
{ fill a subarray with an element }
procedure subfill(var key,destination;
count, sizeof_key,sizeof_element:word);
{ randomly permute the elements of an array }
procedure shuffle(var base; length_base, sizeof_element:word);
{ move subarray to array or array to subarray }
procedure submove(var source,destination;
count, sizeof_source, sizeof_destination:word);
{ move subarray to subarray }
procedure xsubmove(var source,destination;
count,sizeof_source,sizeof_destination,sizeof_move:word);
implementation
function bfind(var key,base; length_base, sizeof_element:word;
f:comparefunc):longint;
var b:array [0..$fffe] of byte absolute base; l,h,x,c:longint;
begin
if length_base>0 then begin
l:=0; h:=pred(length_base);
repeat
x:=(l+h) shr 1; c:=f(key,b[x*sizeof_element]);
if c<0 then h:=pred(x)
else if c>0 then l:=succ(x)
else{if c=0 then}begin bfind:=succ(x); exit; end;
until l>h;
bfind:=-l; end
else bfind:=0; end;
function binsert(var key,base;length_base,sizeof_element:word;
f:comparefunc):word;
var b:array [0..$fffe] of byte absolute base; x:longint;
begin
x:=bfind(key,base,length_base,sizeof_element,f);
if x<=0 then x:=-x else dec(x);
move(b[x*sizeof_element],b[succ(x)*sizeof_element],
(length_base-x)*sizeof_element);
move(key,b[x*sizeof_element],sizeof_element);
binsert:=succ(x); end;
function bsearch(var key,base; length_base, sizeof_element:word;
f:comparefunc):word;
var c:longint;
begin
c:=bfind(key,base,length_base,sizeof_element,f);
if c>0 then bsearch:=c
else bsearch:=0; end;
procedure fill(var key,destination; count, sizeof_element:word);
var b:array [0..$fffe] of byte absolute destination;
x,moved:word;
begin if count>0 then begin
move(key,destination,sizeof_element);
moved:=1; dec(count); x:=sizeof_element;
while count>moved do begin
move(destination,b[x],x);
dec(count,moved); moved:=moved shl 1; x:=x shl 1; end;
move(destination,b[x],count*sizeof_element); end; end;
function lfind(var key,base; length_base, sizeof_element:word;
f:comparefunc):word;
var b:array [0..$fffe] of byte absolute base; i,j:word;
begin
j:=0;
for i:=1 to length_base do begin
if f(key,b[j])=0 then begin lfind:=i; exit end;
inc(j,sizeof_element); end;
lfind:=0; end;
function lsearch(var key,base; length_base, sizeof_element:word;
f:comparefunc):word;
var b:array [0..$fffe] of byte absolute base; i:word;
begin
i:=lfind(key,base,length_base,sizeof_element,f);
if i=0 then begin
move(key,b[length_base*sizeof_element],sizeof_element);
lsearch:=succ(length_base); end
else lsearch:=i; end;
{$ifdef MONITOR}
{ dummy "monitor" }
procedure nullmonitor; begin pointer((@@monitor)^):=NIL end;
{$endif}
procedure qsort(var base; length_base, sizeof_element:word;
f:comparefunc);
var b: array[0..$fffe] of byte absolute base;
j:longint; x:word; y:byte; { not preserved during recursion }
procedure sort(l,r: word);
var i:longint; k:word;
begin
i:=l*sizeof_element; j:=r*sizeof_element;
x:=((longint(l)+r) SHR 1)*sizeof_element;
while i<j do begin
while f(b[i],b[x])<0 do inc(i,sizeof_element);
while f(b[x],b[j])<0 do dec(j,sizeof_element);
if i<j then begin
for k:=0 to pred(sizeof_element) do begin
y:=b[i+k]; b[i+k]:=b[j+k]; b[j+k]:=y; end;
if i=x then x:=j else if j=x then x:=i;
{$ifdef MONITOR}
if @monitor<>nil then monitor;
{$endif}
end;
if i<=j then begin
inc(i,sizeof_element); dec(j,sizeof_element) end; end;
if (l*sizeof_element)<j then sort(l,j div sizeof_element);
if i<(r*sizeof_element) then sort(i div sizeof_element,r); end;
begin sort(0,pred(length_base)); end; {procedure qsort}
procedure shuffle(var base; length_base, sizeof_element:word);
var b: array[0..$fffe] of byte absolute base;
i,ix,j,jx,k:word; y:byte;
begin if length_base>0 then
for i:=pred(length_base) downto 1 do begin
ix:=i*sizeof_element;
j:=random(succ(i));
if i<>j then begin
jx:=j*sizeof_element;
for k:=0 to pred(sizeof_element) do begin
y:=b[ix+k]; b[ix+k]:=b[jx+k]; b[jx+k]:=y; end; end; end; end;
procedure subfill(var key,destination;
count, sizeof_key,sizeof_element:word);
var b:array [0..$fffe] of byte absolute destination; i,j:word;
begin
j:=0;
for i:=1 to count do begin
move(key,b[j],sizeof_key);
inc(j,sizeof_element); end; end;
procedure submove(var source, destination;
count, sizeof_source,sizeof_destination:word);
var sm:word;
begin if sizeof_source=sizeof_destination then
move(source,destination,count*sizeof_source)
else begin
if sizeof_source>sizeof_destination then sm:=sizeof_destination
else sm:=sizeof_source;
xsubmove(source,destination,
count,sizeof_source,sizeof_destination,sm); end; end;
procedure xsubmove(var source,destination;
count,sizeof_source,sizeof_destination,sizeof_move:word);
var a:array [0..$fffe] of byte absolute destination;
b:array [0..$fffe] of byte absolute source;
i,j,k,sm:word;
begin
j:=0; k:=0;
for i:=1 to count do begin
move(b[k],a[j],sizeof_move);
inc(j,sizeof_destination); inc(k,sizeof_source) end; end;
{$ifdef MONITOR}
begin {initialization}
nullmonitor;
{$endif}
end.